home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacHack 1994
/
MacHack 1994.toast
/
MacHack™94
/
Talks & Papers
/
Timothy Knox
/
Pocket6.3
/
Examples
/
Calculator
next >
Wrap
Text File
|
1994-06-24
|
18KB
|
404 lines
page 0 28 +md ! ( kill echo )
\ A simple RPN floating point calculator.
\ includes cut, copy, paste and undo!
\ press tab to return to Pocket Forth.
forget task : task ; decimal
\ rect stuff
: RECT ( compile: -- ) \ define named storage for rect structure
( run: -- addr ) variable 6 allot ;
: !RECT ( t l b r addr -- ) \ set rect data
>r swap r 4 + 2! swap r> 2! ;
: RERASE ( rect -- ) a>r ,$ A8A3 ( _EraseRect ) ;
: RFRAME ( rect -- ) a>r ,$ A8A1 ( _FrameRect ) ;
: RCLIP ( rect -- ) a>r ,$ A87B ( _ClipRect ) ;
\ window stuff
: WINDOW ( -- d ) 0 +md 2@ ; \ d = window pointer
: WSIZE ( h v -- ) \ change the window size
2dup 8 +md 2! \ set the scroll rect
window 2>r 2>r 256 >r ,$ A91D ( _SizeWindow )
4 +md rclip ; \ set drawing rect to whole window
: WTITLE ( string.addr -- ) \ set the window title
window 2>r a>r ,$ A91A ( _SetWTitle ) ;
\ font stuff
: !FONT ( n -- ) >r ,$ A887 ( _TextFont ) ; macro \ set font
: !FSIZE ( n -- ) >r ,$ A88A ( _TextSize ) ; macro \ set size
: !FACE ( face -- ) >r ,$ A888 ( _TextFace ) ; macro \ set style
: !FMODE ( mode -- ) >r ,$ A889 ( _TextMode ) ; macro \ set mode
: SYSFONT ( -- ) 0 !font 12 !fsize ; \ set System font
: MONACO9 ( -- ) 4 !font 09 !fsize 0 !fmode ; \ set Normal font
\ old style (ie easy) color stuff
: BLACK 33 0 2>r ,$ A862 ( _ForeColor ) ; \ black
: RED 205 0 2>r ,$ A862 ( _ForeColor ) ; \ red
: BLUE 409 0 2>r ,$ A862 ( _ForeColor ) ; \ blue
\ string stuff
: ?DEFINING ( -- flag ) cstate c@ ; \ true if defining
: ASCII ( -- c ) 32 word here 1+ c@ \ c = ascii of next character
?defining IF literal THEN ; IMMEDIATE
: EVEN ( n -- n' ) dup 2 mod + ; \ round up to even number
: ," ( -- ) ascii " word \ get a quoted string
here c@ 1+ even allot ; IMMEDIATE
\ memory stuff: macros and create/dispose of handles
: >D0 ( n -- ) ,$ 4280 ,$ 301E ; macro \ clr.l d0 move (a6)+,d0
: >A0 ( d -- ) ,$ 205E ; macro \ movea.l (a6)+,a0
: >A1 ( d -- ) ,$ 225E ; macro ( movea.l [a6]+,a0 )
: D0> ( -- n ) ,$ 3D00 ; macro \ move d0,-(a6)
: A0> ( -- d ) ,$ 2D08 ; macro \ move.l a0,-(a6)
: HNEW ( size -- handle ) \ create a new handle
>d0 ,$ A122 ( _NewHandle ) \ create a block
a0> d0> IF \ check for error
beep 2r> 2drop exit THEN ; \ beep & skip enclosing word
: HDISP ( handle -- ) \ get rid of a handle
>a0 ,$ A023 ( _DisposHandle ) ;
: BMOVE ( d.from d.to n -- ) \ move n bytes d.from -> d.to
>d0 >a1 >a0 ,$ A02E ( _BlockMove ) ;
\ stack checking
: NEEDS ( n -- flag ) depth 1- > ; \ true if less than n items on stack
: ?OVERFLOW ( -- flag ) 1000 needs ; \ true if stack is not overflowing
\ be sure 1 or 2 fp numbers are on the stack for operations
: UNARY ( ? -- f ) 5 needs IF 0.0 THEN ; \ operation requires 1 arg.
: BINARY ( ? -- f1 f2 ) 10 needs IF unary 0.0 fswap THEN ; \ 2 args.
\ fp comparison
: FC ( f1 f2 -- tristate.flag ) fcompare >r fdrop fdrop r> ;
: F0= ( f -- flag ) 0.0 fc 0= ; \ true if f=0
: F> ( f1 f2 -- flag ) fc 0> ; \ true if f1>f2
: F< ( f1 f2 -- flag ) fc 0< ; \ true if f1<f2
\ trancendental functions (not included in Pocket Forth)
: ACOS ( f -- acos[f] ) \ See Apple Numerics Manual, 2nd ed.
fdup 1.0 fswap f- fswap 1.0 f+ f/ fsqrt fatn 2.0 f* ;
: ASIN ( f -- asin[f] ) \ See Apple Numerics Manual, 2nd ed.
fdup fabs 1.16415321827e-10 fcompare >r fdrop r> 0> IF
fdup 0.5 fcompare >r fdrop fdrop r> 0> IF
1. fswap f- fdup 2. f* fswap fdup f* f- ELSE
1. fswap fdup f* f- THEN
fsqrt f/ fatn ELSE
fdrop THEN ;
: PI ( -- f ) 0.0 acos 2.0 f* ; \ 3.14159265358979324
: D/R ( -- f ) 360. pi 2.0 f* f/ ; \ degrees/radian
: LOG ( f -- logf ) fln 10. fln f/ ; \ log base 10
\ : E ( -- f.e 7.0 fdup fln 1.0 fswap f/ f^ ; \ Euler's number
\ compile time ticking See file "Using Starting Forth".
: ['] ( -- addr ) \ of the next word in a colon definition
token latest search IF literal
ELSE here count type space ." not found." abort
THEN ; IMMEDIATE
\ *** Application Specific part follows ***
\ some rects for drawing
rect UPPER_RECT 0 0 75 201 upper_rect !rect \ stack area window
rect MARGIN_RECT 8 7 97 185 margin_rect !rect \ leave a margin
rect BUFFER_RECT 75 10 95 175 buffer_rect !rect \ input buffer rect
\ window titles
create "POCKETFORTH" ," Pocket Forth"
create "CALCULATOR" ," Calculator"
\ display the stack
variable PLACES 9 places ! \ number of decimal places to show
: SPACES ( n -- ) 0 DO space LOOP ; \ emit n spaces NEVER BE ZERO!
: BIG_CR ( -- ) @pen swap drop 16 + 1 swap !pen ; \ bigger cr
: L. ( n -- ) \ n = nth fp number on stack ( auto-formatting display )
5 spaces dup 5 * needs 0= IF
fpick ELSE drop 0.0 THEN \ -- f
fdup \ If real number, f, is
fdup fabs 1.e9 f> >r \ bigger than 1 billion
fdup fabs 1.e-4 f< >r \ or less than .0001
f0= 0= r> r> or and IF \ but not zero...
places @ sci ELSE \ do scientific notation
places @ fix THEN \ do fixed point notation
f. big_cr ; \ show it, then move down
: .STACK ( fn..f1 -- fn..f1 ) \ display fstack
margin_rect rclip \ clip to keep margin clear
sysfont upper_rect rerase \ chicago 12, erase top of window
1 20 !pen \ set starting place
4 l. 3 l. 2 l. 1 l. ; \ display 4 lines
\ display annunciators
fvariable ATYPE 1. atype f! \ 1=radians d/r=degrees
: .ANNUNCIATOR \ draw angle type annunciator
margin_rect rclip \ clip to keep margin clear
180 90 !pen monaco9 red \ red pen
atype f@ 1.0 f- f0= IF \ 1=radians othert = degrees
." R" ELSE ." D" THEN black ;
\ key press handling
variable KFLAG \ holds the pressed key
: !KEY ( c -- ) kflag ! ; 0 !key \ set key pressed
: @KEY ( -- c ) kflag @ ; \ get last key pressed
: ?NUMERIC ( c -- flag ) \ true if c is numeric (or e or .)
dup 101 = >r ( e )
dup 69 = >r ( E )
dup 46 = >r ( . )
dup 47 > >r ( 0 ... 9 )
58 < r> and r> or r> or r> or ;
\ buffer key presses
variable KBUFF 32 allot \ hold multibyte input
variable ^KBUFF kbuff ^kbuff ! \ place holder for above
: #CHARS ( -- n ) \ no. of characters in input buffer
^kbuff @ kbuff 1+ - ;
: KEY>BUFFER ( -- ) \ store the key into kbuff
@key ^kbuff @ c! \ store character
1 ^kbuff +! \ increment pointer
#chars kbuff c! ; \ store length
\ put fp number on stack
: FIRST_CHAR ( -- addr ) kbuff 1+ ; \ first char of kbuff
: INSERT_CHAR ( c -- ) \ insert c at start of kbuff
first_char kbuff 2+ #chars cmove \ move chars up one
first_char c! \ store c at beginning
kbuff c@ 1+ kbuff c! \ incerment count
1 ^kbuff +! ; \ increment index
: ENTER ( -- ) \ convert input buffer to a number
#chars IF \ if there's any numbers
kbuff upper \ be sure its E not e
first_char c@ 69 = IF 49 insert_char THEN \ insert 1 if E
first_char c@ 46 = IF 48 insert_char THEN \ insert 0 if .
kbuff >abs fnumber \ convert to number
first_char ^kbuff ! 0 kbuff ! \ reset buffer
THEN ;
\ display the input buffer
: .BUFFER
buffer_rect rclip 22 90 !pen \ restrict pen to input area
buffer_rect rerase \ clear input rect
kbuff c@ IF sysfont kbuff count type THEN \ type input buffer
buffer_rect rframe ; \ draw frame
\ display calculator
: .CALC ( -- ) .stack .buffer .annunciator ;
\ undo, cut, copy, paste & clear
variable UDEPTH
: UBUFF ( -- addr ) here 300 + ; \ here+300 is used for the undo buffer
: EMPTY_STACK depth 0 DO drop LOOP ; \ clear stack
: KEEP ( -- ) \ save the stack in the undo buffer
depth 5 / udepth !
udepth @ 0 DO \ put each fp number from stack into undo buffer
r 1+ fpick ubuff r 10 * + f! LOOP ;
: RESTORE_STACK ( -- ... ) empty_stack \ restore the stack
udepth @ IF
udepth @ 0 DO \ put each item from undo buffer onto stack
ubuff udepth @ 1- 10 * + r 10 * - f@ LOOP THEN ;
: UNDO ( -- ... ) restore_stack .calc ;
2variable IHANDLE \ temporary handle holder
: DEREF ( addr -- daddr ) 2@ dl@ ; \ dereference a handle at addr
: HANDLE>HERE ( n addr -- ) \ move n bytes from handle to here
deref \ get pointer from handle
rot dup here ! \ store length
here 2+ >abs rot bmove \ move to here+2
here 1+ here here 1+ c@ 1+ cmove ; \ move to here
: SCRAP>STACK ( -- f ) \ Put ascii scrap onto stack as an fp number.
10 hnew ihandle 2! \ create a handle
0 0 2>r \ room for result
ihandle 2@ 2>r \ push handle to rstack
,s TEXT 2>r \ scrap type identifier
here a>r \ offset variable
,$ A9FD ( _GetScrap )
2r> 0< IF \ high byte indicates an error
drop \ drop bytes
ELSE \ no error
ihandle handle>here \ move string to here
here >abs fnumber \ convert string to number
THEN ihandle 2@ hdisp ; \ dispose of the handle
: PASTE ( -- ) keep scrap>stack .calc ;
: F>HERE ( f -- f ) \ displaying a fp number leaves a copy at here
@pen 2>r 1 -20 !pen fdup f. 2r> !pen ; \ copy f to here
: STACK>SCRAP ( f -- f ) \ copy f to clipboard
0 0 2>r ,$ A9FC ( _ZeroScrap )
f>here here c@ 0 2>r \ push length to rstack
,s TEXT 2>r \ scrap type identifier
here 1+ a>r \ addr of text
,$ A9FE \ _PutScrap
2r> + IF beep THEN ; \ beep if error
: COPY enter unary stack>scrap .calc ;
: CUT keep enter unary stack>scrap fdrop .calc ;
: CLEAR keep empty_stack .stack ;
\ draw a tiny help screen (If turnkeying, use an alert.)
: .HELP ( -- )
4 +md rclip page monaco9 8 !fsize blue
10 9 !pen ." l loG n nat loG x e^ +"
10 17 !pen ." \ abs f fraction i int -"
10 25 !pen ." s sin c cos t tan *"
10 33 !pen ." S asin C acos T atan /"
10 41 !pen ." oPt-P ∏ r radians d deG ^"
10 49 !pen ." dn/del droP uP duPlicate"
10 57 !pen ." left swaP riGht roll"
10 65 !pen ." = chanGe siGn — reciPricol"
10 73 !pen ." [ less places ] more places"
black buffer_rect rframe
22 90 !pen sysfont red ." Press a key to go on." ;
\ define and execute commands via a look up table:
\ 32 bit enties: key.char(16), rel.addr(16)
\
variable #DEFS 0 #defs ! \ number of keys defined
400 constant DEF.TABLE.SIZE \ amount of space for key def. table
variable DEF.TABLE def.table.size allot \ key definition table
\ find a character in the table, return its index
: CHAR>INDEX ( c -- n ) \ c = character (key pressed)
0 swap #defs @ 0 DO \ for each defined key
r 4 * def.table + @ \ check the key.char
over = IF \ if it's a match
swap drop r 1+ swap LEAVE \ leave index into table on stack
THEN LOOP drop ; \ n=0 if no match
\ get the execution address of item n in key definition table
: INDEXED_ROUTINE ( n -- addr ) \ n = 1 based index into def.table
1 - 4 * def.table + 2+ @ ; \ addr = associated execution address
\ handle command key presses
: DOCOMMAND ( -- ) \ execute routine associated with char in kflag
@key char>index ?dup IF indexed_routine execute THEN ;
\ handle numeric key presses
: DONUMBER ( -- ) \ if char in kflag is numeric, put it into buffer
@key ?numeric #chars 19 < and IF key>buffer .buffer THEN ;
\ handle any character
: DOKEY ( c -- ) !key donumber docommand ; \ process a character
\ Fill the table with ascii characters and execution addresses
\ defining words to create routines for individual command keys
: :K ( -- addr ) \ start a key definition
#defs @ 4 * 4 + def.table.size > IF \ check room left in table
beep ." Out of key space." quit \ warn if table is full
ELSE here [ ' ] compile ] THEN ; \ otherwise begin compiling
: ASSIGN_KEY ( addr c -- ) \ assign a char and execution addr
#defs @ 4 * def.table + \ -- addr of next entry in key def table
>r r ! r> 2+ ! \ store addr and char in table
1 #defs +! ; \ increment table index
\ key definitions
\ enter & return
:K ?overflow IF keep \ protect from overflow
#chars IF enter \ if inputting, put on stack
ELSE unary fdup \ otherwise duplicate top o stk
THEN .calc \ enter & return
ELSE beep THEN ; dup 3 assign_key 13 assign_key
\ delete
:K #chars IF
kbuff c@ 1- kbuff c! \ if inputting, back up 1 char
-1 ^kbuff +! .buffer \ otherwise drop from stack
ELSE keep unary fdrop .stack THEN ; dup 8 assign_key \ del = drop
ascii D assign_key \ or D
\ change sign
:K keep enter unary fdup fdup f+ f- .calc ; ascii = assign_key \ +/- sign
\ more/less digits
:K places @ 1- 0 max places ! .stack ; ascii [ assign_key \ less places
:K places @ 1+ 17 min places ! .stack ; ascii ] assign_key \ more places
\ stack manipulation
:K ?overflow IF keep unary fdup .stack THEN ; 30 assign_key \ up = dup
:K keep unary fdrop .stack ; 31 assign_key \ down = drop
:K 10 needs 0= IF keep fswap .calc THEN ; 28 assign_key \ left = swap
:K 10 needs 0= IF
keep depth 5 / froll .calc THEN ; 29 assign_key \ right = roll
\ math functions
:K keep enter binary f+ .calc ; ascii + assign_key \ plus
:K #chars ^kbuff @ 1- c@ dup >r \ if prev char is e or E
101 = r> 69 = or and IF \ then its a negative exponent
key>buffer .buffer ELSE \ so put it in the buffer
keep enter binary f- .calc THEN ; ascii - assign_key \ minus
:K keep enter binary f* .calc ; ascii * assign_key \ times
:K keep enter binary f/ .calc ; ascii / assign_key \ divide
:K keep enter binary f^ .calc ; ascii ^ assign_key \ exponent
:K keep enter unary -1.0 f^ .calc ; ascii _ assign_key \ recipricol
:K keep enter unary fln .calc ; ascii n assign_key \ nat. log
:K keep enter unary fexp .calc ; ascii x assign_key \ e^x
:K keep enter unary fabs .calc ; ascii \ assign_key \ abs. value
:K keep enter unary fint .calc ; ascii i assign_key \ int. part
:K keep enter unary fdup fint f- .calc ; ascii f assign_key \ frac.
:K keep enter unary atype f@ f/ fsin .calc ; ascii s assign_key \ sin
:K keep enter unary atype f@ f/ fcos .calc ; ascii c assign_key \ cos
:K keep enter unary atype f@ f/ ftan .calc ; ascii t assign_key \ tan
:K keep enter unary acos atype f@ f* .calc ; ascii C assign_key \ acos
:K keep enter unary fatn atype f@ f* .calc ; ascii T assign_key \ atan
:K keep enter unary asin atype f@ f* .calc ; ascii S assign_key \ asin
:K ?overflow IF keep pi .stack ELSE beep THEN ; ascii π assign_key \ pi
:K keep enter unary log .calc ; ascii l assign_key \ log
\ set degrees or radians for trig functions
:K 1.0 atype f! .calc ; ascii r assign_key \ radians
:K d/r atype f! .calc ; ascii d assign_key \ degrees
\ help: draws a little table of key assignments
:K ['] .help 14 +md ! \ set update
.help BEGIN ?terminal UNTIL \ display and wait
['] .calc 14 +md ! \ reset update
black page .calc ; ascii ? assign_key
\ tab: returns to Pocket Forth, keeps stack and input buffer
:K 384 178 wsize "pocketforth" wtitle monaco9
big_cr ." Type ‘CALC {return}’ to return to the calculator." cr
['] beep 18 +md @ 2+ @ ! \ reset undo handler
['] beep 18 +md @ 2+ @ 4 + ! \ cut handler
['] beep 18 +md @ 2+ @ 6 + ! \ copy handler
['] beep 18 +md @ 2+ @ 10 + ! \ clear handler
[ 18 +md @ 2+ @ 8 + @ literal ] 18 +md @ 2+ @ 8 + ! \ paste
[ 14 +md @ literal ] 14 +md ! \ reset update handler
[ ' fnumber 34 + @ literal ] ['] fnumber 34 + ! \ reset error
tib 80 32 fill \ clear input buffer
tib >abs ,$ 285E ( move.l [a6]+,a4 ) \ setup input buffer
quit ; 9 assign_key ( tab )
: CALC ( -- ) \ setup and run this program
201 101 wsize "calculator" wtitle \ set window size & title
page sysfont \ set chicago 12 font
300 10 +md ! \ move wrap boundry right
['] undo 18 +md @ 2+ @ ! \ set undo handler
['] cut 18 +md @ 2+ @ 4 + ! \ set cut handler
['] copy 18 +md @ 2+ @ 6 + ! \ set copy handler
['] paste 18 +md @ 2+ @ 8 + ! \ set paste handler
['] clear 18 +md @ 2+ @ 10 + ! \ set clear handler
kbuff 32 32 fill \ empty input buffer
0 kbuff ! first_char ^kbuff ! \ set input buffer
['] .calc 14 +md ! \ set update event
['] whazat ['] fnumber 34 + ! \ fnum error
.calc BEGIN key dokey AGAIN ; \ do it 'til quit
\ To make a turnkey program of this, be sure to load this file
\ into a COPY of Pocket Forth. Then define any apple events you
\ want (see Apple Event examples) and execute the following line:
\ ' calc 26 +md ! save bye \ set startup
\ Pocket Forth will quit. When restarted, the calculator program
\ run automatically.
\ Use Resedit to change the bundle, icon, and signature resources,
\ as well as the menus and the about dialog items to create a stand
\ alone application.
: .TELL \ interactive printing utility
page
." Type “Calc” to enter the calculator program." cr
." Then press “?” for help or ‘tab’ to exit." cr ;
.tell forget .tell
-1 28 +md ! ( restore echo )